home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 090 / byt1186b.arc / RUNGKUT.LBR / THERM.FOR < prev   
Text File  |  1986-04-11  |  1KB  |  49 lines
  1.        implicit double precision (a-h,o-z)
  2.        dimension y(1), work(17), icom(4)
  3.        external thermo
  4.        common etherm,ifeval,j
  5.  
  6.        open(2,file=' ',status='new')
  7.        ifeval=0
  8.        icom(1)=0
  9.        icom(2)=0
  10.        icom(3)=0
  11.        neqn=1
  12.        write(*,*) 'etherm=, imeth=, tola=, tolr='
  13.        read(*,*) etherm,imeth,tola,tolr
  14.        hstart=0.01d0
  15.        y(1)=1.d0
  16.        x0=0.d0
  17.        xb=0.d0
  18.        do 20 j=1,6
  19.      xa=xb
  20.      xb=0.2d0*dble(j)+x0
  21.      abserr=dexp(-etherm*xa)-y(1)
  22.      relerr=abserr/dexp(-etherm*xa)
  23.      write(2,100)xa,y(1),abserr,relerr
  24.      call runkut(xa,y,xb,neqn,tola,tolr,hstart,work,
  25.      &             imeth,ierror,icom,thermo)
  26.      if(ierror.GT.1) then
  27.        write(2,100)xb,y(1),abserr,relerr
  28.        write(2,*)' ERROR-Problem too stiff or is discontinous'
  29.        close(2)
  30.        stop
  31.      end if
  32. 20     continue
  33.        if(icom(4).GT.0) write(2,*) 'Round-off error possible'
  34.        write(2,*) 'Number of function evaluations = ',ifeval
  35.        close (2)
  36.        stop
  37. 100    format(F10.5,4E14.6)
  38.        end
  39. c**********************************************************************
  40.        subroutine thermo (x,y,yprime,neqn)
  41.        implicit double precision (a-h,o-z)
  42.        dimension y(neqn), yprime(neqn)
  43.        common etherm,ifeval,j
  44.  
  45.        yprime(1)= -etherm*y(1)
  46.        if(j.LE.5) ifeval=ifeval+1
  47.        return
  48.        end
  49.